PC Media 7/PC MEDIA CD07.iso/share/prog/pscal108/calendar.pas

Pascal/Delphi Source File | 1994-01-18 | 13.9 KB | 628 lines

{

Various Date and Time Procedures

Rev. 1.08

(c) Copyright 1994, Michael Gallias

Target: Real, Protected, Windows

}

{$V-} {$B-}

Unit Calendar;

Interface

{$IFDEF WINDOWS}

Uses WinDos, PasStr;

{$ELSE}

Uses Dos, PasStr;

{$ENDIF}

Const
  dts_DDMYYYY       =  1;
  dts_DDMMYYYY      =  2;
  dts_DDMMMYYYY     =  3;

Type
  TimeDate = Record
               Year,
               Month,
               Day,
               WeekDay,
               Hour,
               Min,
               Sec,
               ms         :Word;
             End;

  DayNameString   = String[9];
  DayNameArray    = Array [0..6] of DayNameString;
  MonthNameString = String[10];
  MonthNameArray  = Array [1..12] of MonthNameString;
  MonthAbrString  = String[3];
  MonthAbrArray   = Array [1..12] of MonthAbrString;

Const
  DayName     : DayNameArray =
                  ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
                   'Thursday', 'Friday', 'Saturday');

  MonthName   : MonthNameArray =
                  ('January', 'February', 'March', 'April', 'May',
                   'June', 'July', 'August', 'September',
                   'October', 'November', 'December');

  MonthAbr    : MonthNameArray =
                  ('Jan', 'Feb', 'Mar', 'Apr', 'May',
                   'Jun', 'Jul', 'Aug', 'Sep',
                   'Oct', 'Nov', 'Dec');

Procedure StringToDate      (Strg:String; Var Date:TimeDate;
                             Const Style:Byte; Var Code:Integer);
Procedure DateToString      (Date:TimeDate; Var Strg:String; Const Style:Byte);
Procedure StringToTime      (Strg:String; Var Time:TimeDate; Var Code:Integer);
Procedure TimeToString      (Time:TimeDate; Var Strg:String);
Procedure MMDDToDDMM        (DateIn:String; Var DateOut:String);
Procedure GetTimeDate       (Var Time:TimeDate);
Procedure PredMin           (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
Procedure PredHour          (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
Procedure UntotalDays       (Total:LongInt; Var Date:TimeDate);
Procedure DayOfWeek         (Var   Date:TimeDate);
Function  DayOfYear         (Const Date:TimeDate):Word;
Function  TotalMonths       (Const Date:TimeDate):LongInt;
Function  TotalDays         (Const Date:TimeDate):LongInt;
Function  TotalHalfHrs      (Const Time:TimeDate):Byte;
Function  TotalMinutes      (Const Time:TimeDate):Word;
Function  TotalSeconds      (Const Time:TimeDate):LongInt;
Function  Totalms           (Const Time:TimeDate):LongInt;
Function  ChangedTime       (Const Time1, Time2:TimeDate):Boolean;
Function  ChangedTimeDate   (Const Time1, Time2:TimeDate):Boolean;
Function  ChangedDate       (Const Date1, Date2:TimeDate):Boolean;
Function  DaysInMonth       (Month:Byte;Year:Word):Byte;
Function  DaysInYear        (Year:Word):Word;

Implementation

Procedure StringToDate(Strg:String;Var Date:TimeDate;
                       Const Style:Byte; Var Code:Integer);

Var
  SY,SM,SD,ST :String;
  AY,AM,AD,AT :LongInt;

Begin
  Code:=0;
  Case Style Of
    dts_DDMMYYYY:
      Begin
        Strg:=Strg+'/';
        SY:='';
        SM:='';
        SD:='';

        SD:=Copy(Strg,1,Pos('/',Strg)-1);
        Delete(Strg,1,Pos('/',Strg));

        If Pos('/',Strg)>0 Then
        Begin
          SM:=Copy(Strg,1,Pos('/',Strg)-1);
          Delete(Strg,1,Pos('/',Strg));
        End;

        If Pos('/',Strg)>0 Then
        Begin
          SY:=Copy(Strg,1,Pos('/',Strg)-1);
          Delete(Strg,1,Pos('/',Strg));
        End;

        If SY<>'' Then
        Begin
          If Length(SY)<3 Then SY:='19'+SY;
          Val(SY,AY,Code);
          If (AY<1991) Or (AY>1999) Then Code:=6;
        End
        Else
          Code:=6;

        If SM<>'' Then
        Begin
          Val(SM,AM,Code);
          If (AM<1) Or (AM>12) Then Code:=3;
        End
        Else
          Code:=3;

        If SD<>'' Then
        Begin
          Val(SD,AD,Code);
          If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
        End
        Else
          Code:=1;
      End;
    dts_DDMMMYYYY,
    dts_DDMYYYY:
      Begin
        Strg:=Strg+'   ';
        SD:=Copy(Strg,1,Pos(' ',Strg)-1);
        Delete(Strg,1,Pos(' ',Strg));
        SM:=Copy(Strg,1,Pos(' ',Strg)-1);
        Delete(Strg,1,Pos(' ',Strg));
        SY:=Copy(Strg,1,Pos(' ',Strg)-1);
        If (SD='') Or (SM='') Or (SY='') Then
          Code:=99
        Else
        Begin
          UpperCase(SM,SM);
          AT:=0;
          Repeat
            Inc(AT);
            UpperCase(MonthName[AT],ST);
          Until (AT=12) Or (ST=SM);
          If ST<>SM Then
          Begin
            AT:=0;
            Repeat
              Inc(AT);
              UpperCase(MonthAbr[AT],ST);
            Until (AT=12) Or (ST=SM);
          End;
          If ST=SM Then AM:=AT Else Code:=3;
          If Code=0 Then
          Begin
            If Length(SY)<3 Then SY:='19'+SY;
            Val(SY,AY,Code);
            If (AY<1991) Or (AY>1999) Then Code:=6;
          End;
          If Code=0 Then
          Begin
            Val(SD,AD,Code);
            If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
          End;
        End;
      End;
  End;
  If Code=0 Then
  Begin
    Date.Day   :=AD;
    Date.Month :=AM;
    Date.Year  :=AY;
  End;
End;

Procedure DateToString(Date:TimeDate;Var Strg:String;Const Style:Byte);

Var
  Temp:String[20];

Begin
  Case Style Of
    dts_DDMYYYY:
      Begin
        Str(Date.Day:2,Strg);
        SpacesToZeros(Strg,Strg);
        Temp:=MonthName[Date.Month];
        Strg:=Strg+' '+Temp+' ';
        Str(Date.Year:4,Temp);
        Strg:=Strg+Temp;
      End;
    dts_DDMMYYYY:
      Begin
        Str(Date.Day:2,Strg);
        Str(Date.Month:2,Temp);
        Strg:=Strg+'/'+Temp+'/';
        Str(Date.Year:4,Temp);
        Strg:=Strg+Temp;
        SpacesToZeros(Strg,Strg);
      End;
    dts_DDMMMYYYY:
      Begin
        Str(Date.Day:2,Strg);
        SpacesToZeros(Strg,Strg);
        Temp:=MonthAbr[Date.Month];
        Strg:=Strg+' '+Temp+' ';
        Str(Date.Year:4,Temp);
        Strg:=Strg+Temp;
      End;
  End;
End;

Procedure StringToTime(Strg:String;Var Time:TimeDate;Var Code:Integer);

Var
  SH,SM,SS:String[10];
  AH,AM,AS:LongInt;

Begin
  Strg:=Strg+':';
  SH:='';
  SM:='';
  SS:='';

  SH:=Copy(Strg,1,Pos(':',Strg)-1);
  Delete(Strg,1,Pos(':',Strg));

  If Pos(':',Strg)>0 Then
  Begin
    SM:=Copy(Strg,1,Pos(':',Strg)-1);
    Delete(Strg,1,Pos(':',Strg));
  End;

  If Pos(':',Strg)>0 Then
  Begin
    SS:=Copy(Strg,1,Pos(':',Strg)-1);
    Delete(Strg,1,Pos(':',Strg));
  End;

  If SH<>'' Then
  Begin
    Val(SH,AH,Code);
    If (Code>0) Or (AH<0) Or (AH>23) Then Exit;
  End
  Else
    AH:=Time.Hour;

  If SM<>'' Then
  Begin
    Val(SM,AM,Code);
    If (Code>0) Or (AM<0) Or (AM>59) Then Exit;
  End
  Else
    AM:=Time.Min;

  If SS<>'' Then
  Begin
    Val(SS,AS,Code);
    If (Code>0) Or (AS<0) Or (AS>59) Then Exit;
  End
  Else
    AS:=Time.Sec;

  Time.Hour  :=AH;
  Time.Min   :=AM;
  Time.Sec   :=AS;
End;

Procedure TimeToString(Time:TimeDate;Var Strg:String);

Var
  Temp:String[10];

Begin
  Str(Time.Hour:2,Strg);
  Str(Time.Min:2,Temp);
  Strg:=Strg+':'+Temp+':';
  Str(Time.Sec:2,Temp);
  Strg:=Strg+Temp;
  SpacesToZeros(Strg,Strg);
End;

Procedure MMDDToDDMM(DateIn:String;Var DateOut:String);

Var
  First    :String[12];
  P        :Byte;

Begin
  If DateIn='' Then
  Begin
    DateOut:='';
    Exit;
  End;

  DateOut:='';
  DateIn:=DateIn+' ';
  P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
  First:=Copy(DateIn,1,P);
  Delete(DateIn,1,P);

  Repeat
    P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
    DateOut:=DateOut+Copy(DateIn,1,P);
    Delete(DateIn,1,P);
  Until Length(DateIn)=0;
  P:=Max(Pos(' ',DateOut),Pos('/',DateOut));
  Insert(First,DateOut,P);
End;

Procedure GetTimeDate(Var Time:TimeDate);
Begin
  With Time do
  Begin
    GetTime(Hour,Min,Sec,ms);
    GetDate(Year,Month,Day,WeekDay);
  End;
End;

Procedure PredMin(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
{Decreases the Time by one Minute, does not check the date if TimeOut.Day=0.}
Begin
  TimeOut:=TimeIn;
  With TimeOut do
  Begin
    If Min>0 Then
      Dec(Min)
    Else
    Begin
      Min:=59;
      If Hour>0 Then
        Dec(Hour)
      Else
      Begin
        Hour:=23;
        If Day>0 Then
        Begin
          If Day>1 Then
            Dec(Day)
          Else
          Begin
            If Month>1 Then
              Dec(Month)
            Else
            Begin
              Month:=12;
              If Year>0 Then Dec(Year);
            End;
            Day:=DaysInMonth(Month,Year);
          End;
        End;
      End;
    End;
  End;
End;

Procedure PredHour(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
{Decreases the Time by one Hour, does not check the date if TimeOut.Day=0.}
Begin
  TimeOut:=TimeIn;
  With TimeOut do
  Begin
    If Hour>0 Then
      Dec(Hour)
    Else
    Begin
      Hour:=23;
      If Day>0 Then
      Begin
        If Day>1 Then
          Dec(Day)
        Else
        Begin
          If Month>1 Then
            Dec(Month)
          Else
          Begin
            Month:=12;
            If Year>0 Then Dec(Year);
          End;
          Day:=DaysInMonth(Month,Year);
        End;
      End;
    End;
  End;
End;

Procedure UntotalDays(Total:LongInt; Var Date:TimeDate);

Const
  t_1000    = 365608;   {Number of days from 0 to 1000, inclusive}
  t_1500    = 548229;
  t_1750    = 639540;
  t_1970    = 719893;

Var
  DIY, DIM      :Word;

Begin
  FillChar(Date,SizeOf(Date),0);

  If Total>t_1970 Then
  Begin
    Dec(Total,t_1970);
    Date.Year:=1971;
  End
  Else
  If Total>t_1750 Then
  Begin
    Dec(Total,t_1750);
    Date.Year:=1751;
  End
  Else
  If Total>t_1500 Then
  Begin
    Dec(Total,t_1500);
    Date.Year:=1501;
  End
  Else
  If Total>t_1000 Then
  Begin
    Dec(Total,t_1000);
    Date.Year:=1001;
  End;

  DIY:=DaysInYear(Date.Year);
  While (Total>DIY) do
  Begin
    Dec(Total,DaysInYear(Date.Year));
    Inc(Date.Year);
    DIY:=DaysInYear(Date.Year);
  End;

  Date.Month:=1;
  For DIY:=1 to 12 do
  Begin
    DIM:=DaysInMonth(DIY,Date.Year);
    If Total>DIM Then
    Begin
      Dec(Total,DIM);
      Inc(Date.Month);
    End;
  End;

  Date.Day:=Total;
End;

Procedure DayOfWeek(Var Date:TimeDate);
{Sets 'WeekDay' of Date: 1 for Monday, 0 for Sunday}
Var
  A,B,C    :Word;
  Y,M,D,DOW:Word;

Begin
  GetDate(Y,M,D,DOW);
  SetDate(Date.Year,Date.Month,Date.Day);
  GetDate(A,B,C,Date.WeekDay);
  SetDate(Y,M,D);
End;

Function DayOfYear(Const Date:TimeDate):Word;

Var
  Temp  :Word;
  X     :Byte;

Begin
  Temp:=Date.Day;
  For X:=1 to Date.Month-1 do
    Inc(Temp,DaysInMonth(X,Date.Year));
  DayOfYear:=Temp;
End;

Function TotalMonths(Const Date:TimeDate):LongInt;
Begin
  TotalMonths:=(12 * (Date.Year - 1)) + Date.Month;
End;

Function TotalDays(Const Date:TimeDate):LongInt;

{Returns the total number of days that have elapsed from the year 0, including
 the current day, e.g. 1 Jan 0 = 1}

Const
  t_1_1_1970    = 719529;

Var
  Total:LongInt;
  Year :Integer;
  Month:Byte;
  Start:Integer;

Begin
  If Date.Year>=1970 Then
  Begin
    Total:=t_1_1_1970-1;
    Start:=1970;
  End
  Else
  Begin
    Total:=0;
    Start:=0;
  End;

  For Year:=Start to Integer(Date.Year)-1 do
    Inc(Total,DaysInYear(Year));

  For Month:=1 to Date.Month-1 do
    Inc(Total,DaysInMonth(Month,Date.Year));
  TotalDays:=Total+Date.Day;
End;

Function TotalHalfHrs(Const Time:TimeDate):Byte;
Begin
  TotalHalfHrs:=Time.Hour * 2 + (Time.Min Div 30);
End;

Function TotalMinutes(Const Time:TimeDate):Word;
Begin
  TotalMinutes:=Time.Hour*60+Time.Min;
End;

Function TotalSeconds(Const Time:TimeDate):LongInt;
Begin
  TotalSeconds:=LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec);
End;

Function Totalms(Const Time:TimeDate):LongInt;
Begin
  Totalms:=(LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec))*100+LongInt(Time.ms);
End;

Function ChangedTime(Const Time1, Time2:TimeDate):Boolean;
Begin
  If (Time1.ms  =Time2.ms  ) And
     (Time1.Sec =Time2.Sec ) And
     (Time1.Min =Time2.Min ) And
     (Time1.Hour=Time2.Hour) Then
    ChangedTime:=False
  Else
    ChangedTime:=True;
End;

Function ChangedTimeDate(Const Time1, Time2:TimeDate):Boolean;
Begin
  If (Time1.ms   =Time2.ms   ) And
     (Time1.Sec  =Time2.Sec  ) And
     (Time1.Min  =Time2.Min  ) And
     (Time1.Hour =Time2.Hour ) And
     (Time1.Day  =Time2.Day  ) And
     (Time1.Month=Time2.Month) And
     (Time1.Year =Time2.Year ) Then
    ChangedTimeDate:=False
  Else
    ChangedTimeDate:=True;
End;

Function ChangedDate(Const Date1, Date2:TimeDate):Boolean;
Begin
  If (Date1.Day  =Date2.Day  ) And
     (Date1.Month=Date2.Month) And
     (Date1.Year =Date2.Year ) Then
    ChangedDate:=False
  Else
    ChangedDate:=True;
End;

Function DaysInMonth(Month:Byte;Year:Word):Byte;
Begin
  Case Month Of
     1:DaysInMonth:=31;
     2:Begin
         If (Year Mod 100)=0 Then      {Centuary}
           If (Year Mod 400)=0 Then
             DaysInMonth:=29
           Else
             DaysInMonth:=28
         Else                          {Non Centuary}
           If (Year Mod 4)=0 Then
             DaysInMonth:=29
           Else
             DaysInMonth:=28;
       End;
     3:DaysInMonth:=31;
     4:DaysInMonth:=30;
     5:DaysInMonth:=31;
     6:DaysInMonth:=30;
     7:DaysInMonth:=31;
     8:DaysInMonth:=31;
     9:DaysInMonth:=30;
    10:DaysInMonth:=31;
    11:DaysInMonth:=30;
    12:DaysInMonth:=31;
  End;
End;

Function DaysInYear(Year:Word):Word;
Begin
  If DaysInMonth(2,Year)=29 Then DaysInYear:=366 Else DaysInYear:=365;
End;

End.